home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / cml-098.lha / cml-0.9.8 / src / run-cml.sml < prev    next >
Encoding:
Text File  |  1993-02-04  |  3.2 KB  |  118 lines
  1. (* run-cml.sml
  2.  *
  3.  * COPYRIGHT (c) 1990 by John H. Reppy.  See COPYRIGHT file for details.
  4.  *
  5.  * Code to support top-level interactive use of CML.
  6.  *)
  7.  
  8. functor RunCML (CML : INTERNAL_CML) : RUN_CML =
  9.   struct
  10.  
  11.     exception Unlog
  12.  
  13.     local
  14.       datatype item = ITEM of {
  15.       key : string,
  16.       init : unit -> unit,
  17.       shut : unit -> unit
  18.     }
  19.       val chanList = ref ([] : item list)
  20.       val serverList = ref ([] : item list)
  21.       fun unlogItem l name = let
  22.         fun f [] = raise Unlog
  23.           | f ((x as ITEM{key, ...})::r) = if (name = key) then r else (x :: (f r))
  24.         in
  25.           l := f(!l)
  26.         end
  27.       fun appInit l () = revapp (fn ITEM{init, ...} => init()) (!l)
  28.     in
  29.     fun unlogAll () = (chanList := []; serverList := [])
  30.  
  31.     val unlogChannel = unlogItem chanList
  32.     fun logChannel(name, ch) = let
  33.       fun f () = CML.resetChan ch
  34.       in
  35.         (unlogChannel name) handle Unlog => ();
  36.         chanList := ITEM{key=name, init=f, shut=f} :: (!chanList)
  37.       end
  38.  
  39.     val unlogServer = unlogItem serverList
  40.     fun logServer (name, f, g) = (
  41.       (unlogServer name) handle Unlog => ();
  42.       serverList := ITEM{key=name, init=f, shut=g} :: (!serverList))
  43.     fun cleanChannels () = (CML.resetChan CML.errCh; appInit chanList ())
  44.     val startServers = appInit serverList
  45.     fun shutdownServers () = let
  46.       fun shut (ITEM{key, shut, ...}) = CML.sync (CML.choose [
  47.           CML.threadWait(CML.spawn shut),
  48.           CML.wrap(CML.timeout(CML.TIME{sec=5, usec=0}),
  49.             fn () => CML.CMLBase.reportError("shutdown "^key^" timeout"))
  50.         ])
  51.       in
  52.         app shut (!serverList)
  53.       end
  54.     end (* local *)
  55.  
  56.   (* run the system *)
  57.     local
  58.       val setitimer = System.Unsafe.CInterface.setitimer
  59.       fun msToTime NONE = NONE
  60.         | msToTime (SOME t) = SOME(
  61.         if t < 10
  62.           then CML.TIME{sec=0, usec=10000}
  63.           else CML.TIME{sec=(t quot 1000), usec=((t rem 1000)*1000)})
  64.     in
  65.  
  66.     exception Running
  67.     fun doit (initialProc, timeq) = let
  68.       open System.Signals
  69.       val _ = if CML.CMLBase.isRunning() then raise Running else ();
  70.       val saveHdlr = inqHandler SIGINT
  71.       val tq = msToTime timeq
  72.       in
  73.         callcc (fn done => (
  74.           setHandler(SIGINT,
  75.         SOME(fn _ => (
  76.           CML.CMLBase.reportError "\nInterrupt";
  77.           CML.CMLBase.restartTimer(); done)));
  78.           CML.initCML ();
  79.           cleanChannels ();
  80.           CML.CMLBase.shutdown := throw done;
  81.           CML.CMLBase.go tq;
  82.           startServers();
  83.           CML.spawn initialProc;
  84.           CML.exit()));
  85.       (* here on shutdown or ^C *)
  86.         setHandler(SIGINT, saveHdlr);
  87.         shutdownServers ();
  88.         CML.CMLBase.stop();
  89.         cleanChannels ()
  90.       end
  91.  
  92.     fun exportFn (name, f, timeq) = let
  93.       fun cmd args = doit (fn () => (f args), timeq)
  94.       in
  95.         IO.exportFn (name, cmd)
  96.       end
  97.  
  98.     exception NotRunning
  99.     fun shutdown () = (
  100.       if CML.CMLBase.isRunning() then (!CML.CMLBase.shutdown)() else ();
  101.       raise NotRunning)
  102.  
  103.   (* hook our termination code into the SML/NJ shutdown facility *)
  104.     val _ = let open System.Unsafe.CleanUp
  105.       fun clean CleanForQuit = if CML.CMLBase.isRunning()
  106.         then (shutdownServers(); CML.CMLBase.stop())
  107.         else ()
  108.         | clean _ = ()
  109.     in
  110.       addCleaner ("ConcurML", clean)
  111.     end
  112.  
  113.     end (* local *)
  114.  
  115.     structure CML : CONCUR_ML = CML
  116.  
  117.   end (* functor RunCML *)
  118.